home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / oobr / br-ftr.el < prev    next >
Encoding:
Text File  |  1995-08-29  |  14.3 KB  |  423 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         br-ftr.el
  4. ;; SUMMARY:      OO-Browser feature browsing support.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     oop, tools
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Motorola Inc.
  10. ;;
  11. ;; ORIG-DATE:    20-Aug-91 at 18:16:36
  12. ;; LAST-MOD:     25-Aug-95 at 16:54:53 by Bob Weiner
  13. ;;
  14. ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
  15. ;; See the file BR-COPY for license information.
  16. ;;
  17. ;; This file is part of the OO-Browser.
  18. ;;
  19. ;; DESCRIPTION:  
  20. ;; DESCRIP-END.
  21.  
  22. ;;; ************************************************************************
  23. ;;; Public variables
  24. ;;; ************************************************************************
  25.  
  26. (defconst br-feature-type-regexp "[-+=@%>1/]"
  27.   "Regular expression which matches the first non-whitespace characters in an OO-Browser feature listing.")
  28.  
  29. ;;; ************************************************************************
  30. ;;; Public functions
  31. ;;; ************************************************************************
  32.  
  33. (defun br-find-feature (&optional feature-entry view-only other-win)
  34.   "Display feature definition for FEATURE-ENTRY in VIEW-ONLY mode if non-nil.
  35. Return feature path if FEATURE-ENTRY is successfully displayed, nil
  36. otherwise.  Can also signal an error when called interactively."
  37.   (interactive)
  38.   (and (interactive-p) (setq view-only current-prefix-arg))
  39.   (let ((feature-path))
  40.     (setq feature-entry
  41.       (br-feature-signature-and-file
  42.        (or feature-entry
  43.            (br-feature-complete 'must-match "Show feature definition:")))
  44.       feature-path (cdr feature-entry)
  45.       feature-entry (car feature-entry))
  46.     (br-edit-feature feature-entry feature-path other-win view-only)))
  47.  
  48. (defun br-edit-feature (tag-entry feature-path &optional other-win view-only)
  49.   "Edit feature for OO-Browser TAG-ENTRY of file FEATURE-PATH, optionally in OTHER-WIN.
  50. With optional VIEW-ONLY, view feature definition instead of editing it.
  51. Return FEATURE-PATH if feature definition is found, else nil."
  52.   (let ((err))
  53.     (cond ((and feature-path (file-readable-p feature-path))
  54.        (cond ((br-feature-found-p feature-path tag-entry nil other-win)
  55.           (br-major-mode)
  56.           (if view-only 
  57.               (setq buffer-read-only t)
  58.             ;; Handle case of already existing buffer in
  59.             ;; read only mode.
  60.             (and buffer-read-only
  61.              (file-writable-p feature-path)
  62.              (setq buffer-read-only nil)))
  63.           ;; Force mode-line redisplay
  64.           (set-buffer-modified-p (buffer-modified-p)))
  65.          ((interactive-p)
  66.           (setq err
  67.             (format
  68.              "(OO-Browser):  No '%s' feature defined in Environment."
  69.              tag-entry)
  70.             feature-path nil))))
  71.       ((interactive-p)
  72.        (setq err
  73.          (format
  74.           "(OO-Browser):  '%s' - src file not found or not readable, %s"
  75.           tag-entry feature-path)
  76.          feature-path nil)))
  77.     (if err (error err))
  78.     feature-path))
  79.  
  80. (defun br-find-feature-entry ()
  81.   "Return feature entry that point is within or nil."
  82.   (if (= (point) (point-max)) (skip-chars-backward " \t\n"))
  83.   (save-excursion
  84.     (beginning-of-line)
  85.     (if (or 
  86.      (progn (skip-chars-forward " \t")
  87.         (looking-at br-feature-entry))
  88.      ;; Get current feature signature, if any.
  89.      (br-feature-get-signature))
  90.     (let ((feature (buffer-substring
  91.             (point)
  92.             (progn (skip-chars-forward "^\t\n\r") (point)))))
  93.       (if (and (equal br-lang-prefix "objc-")
  94.            ;; Remove any trailing class from a category entry.
  95.            (string-match "@ ([^\)]+)" feature))
  96.           (substring feature 0 (match-end 0))
  97.         feature)))))
  98.  
  99. (defun br-feature-complete (&optional must-match prompt)
  100.   "Interactively completes feature entry if possible, and returns it.
  101. Optional MUST-MATCH means must match a completion table entry.
  102. Optional PROMPT is intial prompt string for user."
  103.   (interactive)
  104.   (let ((default (br-find-feature-entry))
  105.     (completion-ignore-case t)
  106.     completions
  107.     ftr-entry)
  108.     ;; Prompt with possible completions of ftr-entry.
  109.     (setq prompt (or prompt "Feature entry:")
  110.       completions (br-feature-completions)
  111.       ftr-entry
  112.       (if completions
  113.           (completing-read
  114.         (format "%s (default %s) " prompt default)
  115.         completions nil must-match)
  116.         (read-string
  117.           (format "%s (default %s) " prompt default))))
  118.     (if (equal ftr-entry "") default ftr-entry)))
  119.  
  120. (defun br-feature-completions ()
  121.   "Return completion alist of all current Environment elements."
  122.   (cond ((not (and br-feature-tags-file (file-exists-p br-feature-tags-file)
  123.            (file-readable-p br-feature-tags-file)))
  124.      nil)
  125.     ((and br-feature-tags-completions
  126.           (eq
  127.            (car (cdr br-feature-tags-completions)) ;; tags last mod time
  128.            (apply '+ (nth 5 (file-attributes br-feature-tags-file))))
  129.           (equal br-env-file (car br-feature-tags-completions)))
  130.      (car (cdr (cdr br-feature-tags-completions))))
  131.     (t
  132.      (let ((ftr-buf (get-buffer-create "*ftr-buf*"))
  133.            (ftr-alist))
  134.        (save-excursion
  135.          (br-feature-tags-init)
  136.          (copy-to-buffer ftr-buf 1 (point-max))
  137.          (set-buffer ftr-buf)
  138.          (goto-char 1)
  139.          (while (search-forward "\^L" nil t)
  140.            (forward-line 1)
  141.            ;; Skip past pathname where features are defined.
  142.            (while (and (= (forward-line 1) 0)
  143.                (not (looking-at "\^L\\|\\'")))
  144.          (setq ftr-alist (cons (cons (br-feature-signature-to-name
  145.                           (br-feature-current)
  146.                           t)
  147.                          nil)
  148.                        ftr-alist)))))
  149.        (kill-buffer ftr-buf)
  150.        (setq br-feature-tags-completions 
  151.          (list br-env-file
  152.                ;; tags last mod time
  153.                (apply '+ (nth 5 (file-attributes
  154.                      br-feature-tags-file)))
  155.                ftr-alist))
  156.        ftr-alist))))
  157.  
  158. (defun br-feature-def-file (feature-regexp)
  159.   "Return file name in which feature matching FEATURE-REGEXP is, if any.
  160. Assume feature tags file is current buffer and leave point at the start of
  161. matching feature tag, if any."
  162.   (goto-char 1)
  163.   (and (re-search-forward feature-regexp nil t)
  164.        ;; This ensures that point is left on the same line as the feature tag
  165.        ;; which is found.
  166.        (goto-char (match-beginning 0))
  167.        (br-feature-file-of-tag)))
  168.  
  169. (defun br-feature-file (feature-sig)
  170.   "Return file name in which feature matching FEATURE-SIG is, if any."
  171.   (let ((obuf (current-buffer))
  172.     (file))
  173.     (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
  174.     (goto-char 1)
  175.     (if (search-forward feature-sig nil t)
  176.     (setq file (br-feature-file-of-tag)))
  177.     (set-buffer obuf)
  178.     file))
  179.  
  180. (defun br-feature-found-p (buf-file feature-tag
  181.                &optional deferred-class other-win regexp-flag)
  182.   "Search BUF-FILE for FEATURE-TAG.
  183. Return nil if not found, otherwise display it and return non-nil."
  184.   (if buf-file
  185.       (let ((found-def)
  186.         (opoint (point))
  187.         (prev-buf)
  188.         (prev-point)
  189.         (config (current-window-configuration)))
  190.     (setq prev-buf (get-file-buffer buf-file))
  191.     (funcall br-edit-file-function buf-file other-win)
  192.     (setq prev-point (point))
  193.     (widen)
  194.     (goto-char (point-min))
  195.     (setq found-def 
  196.           (cond (deferred-class
  197.               (br-feature-locate-p feature-tag deferred-class))
  198.             (regexp-flag
  199.              (br-feature-locate-p feature-tag regexp-flag))
  200.             (t (br-feature-locate-p feature-tag))))
  201.     (if found-def
  202.         ;; Set appropriate mode for file.
  203.         (br-major-mode)
  204.       (setq buf-file (get-file-buffer buf-file))
  205.       (if prev-buf
  206.           (goto-char prev-point)
  207.         (if buf-file
  208.         (kill-buffer buf-file)
  209.           (goto-char prev-point)))
  210.       (set-window-configuration config)
  211.       (goto-char opoint))
  212.     found-def)))
  213.  
  214. (defun br-feature-name (ftr-entry)
  215.   "Return name part of FTR-ENTRY."
  216.   (if (equal (string-match br-feature-entry ftr-entry) 0)
  217.       (substring ftr-entry (match-beginning 1))
  218.     ""))
  219.  
  220. (defun br-feature-signature-and-file (class-and-feature-name)
  221.   "Return (feature signature . feature-def-file-name) of CLASS-AND-FEATURE-NAME."
  222.   (let ((obuf (current-buffer))
  223.     ;; Find only exact matches
  224.     (name-regexp (br-feature-name-to-regexp class-and-feature-name))
  225.     (result))
  226.     (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
  227.     (goto-char 1)
  228.     (if (re-search-forward name-regexp nil t)
  229.     (progn (goto-char (match-beginning 0))
  230.            (setq result (cons (br-feature-current)
  231.                   (br-feature-file-of-tag)))))
  232.     (set-buffer obuf)
  233.     result))
  234.  
  235. (defun br-feature-signature (&optional arg)
  236.   "Show full feature signature in the view window.
  237. With optional prefix ARG, display signatures of all features from the current
  238. buffer."
  239.   (interactive "P")
  240.   (let* ((buf (buffer-name))
  241.      (owind (selected-window))
  242.      (features (delq nil (if arg (br-feature-get-tags)
  243.                    (list (br-feature-get-signature))))))
  244.     (if (null features)
  245.     (progn (beep) (message "No elements."))
  246.       (br-to-view-window)
  247.       (switch-to-buffer (get-buffer-create (concat buf "-Elements")))
  248.       (setq buffer-read-only nil)
  249.       (erase-buffer)
  250.       (mapcar (function (lambda (feature) (insert feature "\n")))
  251.           features)
  252.       (br-major-mode)
  253.       (goto-char 1)
  254.       (select-window owind)
  255.       (message ""))))
  256.  
  257. ;;; ************************************************************************
  258. ;;; Listing buffer entry tag property handling.
  259. ;;; ************************************************************************
  260.  
  261. (if (string-match "^19\." emacs-version)
  262.     (progn
  263.       ;;
  264.       ;; Emacs 19 buffer entry tags functions
  265.       ;;
  266.  
  267.       (defun br-feature-clear-signatures (&optional buf-nm)
  268.     "Erase any feature signatures saved with current buffer or optional BUF-NM."
  269.     (save-excursion
  270.       (if buf-nm (set-buffer (get-buffer buf-nm)))
  271.       (save-restriction
  272.         (widen)
  273.         (remove-text-properties (point-min) (point-max) '(tag)))))
  274.  
  275.       (defun br-feature-get-signature (&optional line-num-minus-one)
  276.     (save-excursion
  277.       (if (numberp line-num-minus-one)
  278.           (goto-line (1+ line-num-minus-one)))
  279.       (end-of-line)
  280.       (car (cdr (memq 'tag (text-properties-at (1- (point))))))))
  281.  
  282.       (defun br-feature-get-tags ()
  283.     (save-excursion
  284.       (goto-char (point-max))
  285.       (let ((found t)
  286.         (tags)
  287.         tag)
  288.         (while found
  289.           (setq tag (get-text-property (1- (point)) 'tag))
  290.           (if tag (setq tags (cons tag tags)))
  291.           (setq found (= (forward-line -1) 0))
  292.           (end-of-line))
  293.         tags)))
  294.  
  295.       ;; Tag property is placed at end of line in case leading indent is
  296.       ;; removed by an OO-Browser operation.  In that case, we don't want to
  297.       ;; lose the tag property.
  298.       (defun br-feature-put-signatures (ftr-sigs)
  299.     (while ftr-sigs
  300.       (end-of-line)
  301.       (put-text-property (- (point) 2) (point) 'tag (car ftr-sigs))
  302.       (setq ftr-sigs (cdr ftr-sigs))
  303.       (if (and ftr-sigs (/= (forward-line 1) 0))
  304.           (error "(br-feature-put-signatures): Too few lines in this buffer"))))
  305.  
  306.       )
  307.  
  308.   ;;
  309.   ;; Emacs 18 buffer entry tags functions
  310.   ;;
  311.  
  312.   (defun br-feature-clear-signatures (&optional buf-nm)
  313.     "Erase any feature signatures saved with current buffer or optional BUF-NM."
  314.     (put (intern (or buf-nm (buffer-name))) 'features nil))
  315.  
  316.   (defun br-feature-get-signature (&optional line-num)
  317.     (or (numberp line-num)
  318.     (save-excursion
  319.       (beginning-of-line)
  320.       (setq line-num (count-lines 1 (point)))))
  321.     (cdr (assq line-num (get (intern-soft (buffer-name)) 'features))))
  322.  
  323.   (defun br-feature-get-tags ()
  324.     (get (intern-soft (buffer-name)) 'features))
  325.  
  326.   (defun br-feature-put-signatures (ftr-sigs)
  327.     (beginning-of-line)
  328.     (let* ((line (count-lines 1 (point)))
  329.        (meth-alist (mapcar (function
  330.                 (lambda (meth)
  331.                   (prog1 (cons line meth)
  332.                     (setq line (1+ line)))))
  333.                    ftr-sigs))
  334.        (buf-sym (intern (buffer-name))))
  335.       (put buf-sym 'features
  336.        (nconc (get buf-sym 'features) meth-alist))))
  337.   )
  338.  
  339. ;;; ************************************************************************
  340. ;;; END - Listing buffer entry tag property handling.
  341. ;;; ************************************************************************
  342.  
  343. (defun br-feature-tags-init ()
  344.   "Set up 'br-feature-tags-file' for writing."
  345.   (setq br-feature-tags-completions nil
  346.     br-feature-tags-file (br-feature-tags-file-name br-env-file)
  347.     br-tags-file (concat br-env-file "-TAGS"))
  348.   (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
  349.   (setq buffer-read-only nil))
  350.  
  351. (defun br-feature-tags-file-name (env-file)
  352.   (concat env-file "-FTR"))
  353.  
  354. (defun br-feature-tags-save ()
  355.   "Filter out extraneous lines and save 'br-feature-tags-file'."
  356.   (let ((obuf (current-buffer)))
  357.     (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
  358.     (goto-char (point-min))
  359.     (delete-matching-lines "^[ \t]*$")
  360.     (goto-char (point-min))
  361.     (replace-regexp "^[ \t]+\\|[ \t]+$" "")
  362.     (and br-c-tags-flag
  363.      (br-member br-lang-prefix '("c++-" "objc-"))
  364.      (progn (c-build-element-tags)
  365.         (goto-char (point-min))
  366.         (replace-regexp "[ \t]*//.*" "")))
  367.     (goto-char (point-min))
  368.     (delete-matching-lines "^$")
  369.     (save-buffer)
  370.     (set-buffer obuf)))
  371.  
  372. (defun br-insert-features (feature-tag-list &optional indent)
  373.   "Insert feature names from FEATURE-TAG-LIST in current buffer indented INDENT columns."
  374.   (let ((start (point)))
  375.     (mapcar (function
  376.          (lambda (feature-tag)
  377.            (if indent (indent-to indent))
  378.            (if feature-tag
  379.            (insert (br-feature-signature-to-name feature-tag nil t)
  380.                "\n"))))
  381.         feature-tag-list)
  382.     (save-excursion
  383.       (goto-char start)
  384.       (br-feature-put-signatures feature-tag-list))))
  385.  
  386. ;;; ************************************************************************
  387. ;;; Private functions
  388. ;;; ************************************************************************
  389.  
  390. (defun br-feature-current ()
  391.   "Extract current feature from tags file and leave point at the end of line."
  392.   (beginning-of-line)
  393.   (buffer-substring (point) (progn (end-of-line) (point))))
  394.  
  395. (defun br-feature-file-of-tag ()
  396.   "Return the file name of the file whose tag point is within.
  397. Assumes the tag table is the current buffer."
  398.   (save-excursion
  399.     (search-backward " " nil t)
  400.     (forward-line 1)
  401.     (let ((start (point)))
  402.       (end-of-line)
  403.       (buffer-substring start (point)))))
  404.  
  405. ;;; ************************************************************************
  406. ;;; Private variables
  407. ;;; ************************************************************************
  408.  
  409. (defconst br-feature-entry
  410.   (concat br-feature-type-regexp " \\([^\t\n\r]*[^ \t\n\r]\\)")
  411.   "Regexp matching a feature entry in a browser listing buffer.")
  412.  
  413. (defvar br-feature-tags-completions nil
  414.   "List of (envir-name tags-file-last-mod-time tags-completion-alist).")
  415.  
  416. (defvar br-feature-tags-file nil
  417.   "Pathname where current object-oriented feature tags are stored.")
  418.  
  419. (defvar br-tags-file nil
  420.   "Pathname where current non-object-oriented feature tags are stored.")
  421.  
  422. (provide 'br-ftr)
  423.